home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Creative Computers
/
Creative Computers CD-ROM, Volume 1 (Legendary Design Technologies, Inc.)(1994).iso
/
shareware
/
fractals
/
ffex
/
source
/
ilbminout.mod
< prev
next >
Wrap
Text File
|
1994-11-17
|
10KB
|
354 lines
IMPLEMENTATION MODULE IlbmInOut;
FROM Request IMPORT Request;
FROM Arts IMPORT TermProcedure,Assert,BreakPoint;
FROM SYSTEM IMPORT ADR,ADDRESS,CAST,INLINE;
FROM Graphics IMPORT ViewModes,ViewModeSet,BitMapPtr;
FROM Exec IMPORT AllocMem,MemReqSet,MemReqs,FreeMem,CopyMem;
FROM Intuition IMPORT ScreenPtr,NewScreen,customScreen,ScreenFlags,
ScreenFlagSet,OpenScreen,WindowPtr;
FROM Dos IMPORT DeleteFile,Open,Close,Read,Write,Lock,FileHandlePtr,
FileLockPtr,oldFile,newFile,sharedLock,UnLock,
exclusiveLock;
FROM Str IMPORT Concat,Copy;
TYPE
BitMapHeader=RECORD
w,h,x,y : CARDINAL;
planes,
masking,
compression,
pad1 : CHAR;
transpcolor: CARDINAL;
xasp,yasp : CHAR;
pagewidth,
pageheight : CARDINAL;
END;
ILBMFileHeader=RECORD
form : ARRAY[0..3] OF CHAR;
formlen : LONGINT;
ilbmbmhd : ARRAY[0..7] OF CHAR;
bmhdlen : LONGINT;
bmhd : BitMapHeader;
cmapchunk: ARRAY[0..3] OF CHAR;
cmaplen : LONGINT;
cmap : ARRAY[0..31],[0..2] OF CHAR;
camgchunk: ARRAY[0..3] OF CHAR;
camglen : LONGINT;
pad1 : INTEGER;
camg : ViewModeSet;
ffexchunk: ARRAY[0..3] OF CHAR; (* FFEX-spezifischer Chunk *)
ffexlen : LONGINT;
ffex1 : ARRAY[0..3] OF LONGREAL; (* Limits als LONGREALS *)
ffex2 : LONGINT; (* #Iterations als LONGINT *)
bodychunk: ARRAY[0..3] OF CHAR;
bodylen : LONGINT;
END;
VAR
ilbmheader: ILBMFileHeader;
f : FileHandlePtr;
lock : FileLockPtr;
req : BOOLEAN;
bodymem : ADDRESS;
act,
bodybytes : LONGINT;
message : ARRAY[0..255] OF CHAR;
yes,no : ARRAY[0..9] OF CHAR;
PROCEDURE GetByte(s: ADDRESS): LONGINT;
BEGIN RETURN LONGINT(CAST(CHAR, s^)) END GetByte;
PROCEDURE PutByte(v: LONGINT; s: ADDRESS);
BEGIN s^:=CHAR(v) END PutByte;
(*** Prozeduren zum Laden von IFF-ILBM Bildern ***********************)
PROCEDURE UnPackRow(VAR source,dest:ADDRESS;bpr:INTEGER);
VAR count,i,a,b:LONGINT;
BEGIN
count:=0;
WHILE count<bpr DO
a:=GetByte(source); INC(source);
IF a<128 THEN
CopyMem(source,dest,a+1);
INC(source,a+1); INC(dest,a+1); INC(count,a+1);
ELSIF a>128 THEN
b:=GetByte(source); INC(source);
FOR i:=1 TO 257-a DO
dest^:=CHAR(b); INC(dest);
END;
INC(count,257-a);
END;
END;
END UnPackRow;
(*** Es wird ein Screen erzeugt, in den das Bild geladen wird. ***)
(*** Ein Zeiger darauf wird in scr zurückgegeben. ****************)
PROCEDURE LoadILBM(fname:ARRAY OF CHAR; win:WindowPtr;
VAR scr:ScreenPtr;
VAR rmin,imin,rmax,imax:LONGREAL;
VAR maxiter:LONGINT):BOOLEAN;
VAR
source : ADDRESS;
pl : ARRAY[0..7] OF ADDRESS;
i,j : INTEGER;
ns : NewScreen;
BEGIN
lock:=Lock(ADR(fname),sharedLock);
IF lock=NIL THEN
Copy(message,fname); Concat(message,"|not found!");
yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE;
END;
f:=Open(ADR(fname),oldFile);
act:=Read(f,ADR(ilbmheader),SIZE(ilbmheader));
IF act#SIZE(ilbmheader) THEN
Close(f); UnLock(lock); lock:=NIL; f:=NIL;
message:="Load Error!"; yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE
END;
IF CAST(LONGINT,ilbmheader.ffexchunk) # CAST(LONGINT,"FFEX") THEN
Close(f); UnLock(lock); lock:=NIL; f:=NIL;
message:="Sorry, no FFEX-Picture"; yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE;
END;
bodybytes:=ilbmheader.bodylen;
bodymem := AllocMem(bodybytes, MemReqSet{public,memClear});
IF bodymem=NIL THEN
Close(f); UnLock(lock); lock:=NIL; f:=NIL;
message:="Not enough memory!"; yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE;
END;
source := bodymem;
act:=Read(f,source,bodybytes); (* Body laden *)
Close(f); UnLock(lock); lock:=NIL; f:=NIL;
IF act#bodybytes THEN
message:="Load Error!"; yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE
END;
WITH ns DO
width:=ilbmheader.bmhd.w; height:=ilbmheader.bmhd.h;
depth:=INTEGER(ilbmheader.bmhd.planes);
viewModes:=ilbmheader.camg;
type:=customScreen+ScreenFlagSet{screenBehind};
font:=NIL; defaultTitle:=NIL;
gadgets:=NIL; customBitMap:=NIL;
END;
scr:=OpenScreen(ns);
IF scr=NIL THEN
FreeMem(bodymem,bodybytes); bodymem:=NIL;
message:="Not enough memory!"; yes:=""; no:="CANCEL";
IF Request(win,message,yes,no) THEN END;
RETURN FALSE;
END;
FOR i:=0 TO 7 DO pl[i]:=scr^.bitMap.planes[i] END;
FOR i:=0 TO scr^.height-1 DO
FOR j:=0 TO INTEGER(scr^.bitMap.depth)-1 DO
UnPackRow(source,pl[j],scr^.bitMap.bytesPerRow);
END;
END;
FreeMem(bodymem,bodybytes); bodymem:=NIL;
rmin:=ilbmheader.ffex1[0];
imin:=ilbmheader.ffex1[1];
rmax:=ilbmheader.ffex1[2];
imax:=ilbmheader.ffex1[3];
maxiter:=ilbmheader.ffex2;
RETURN TRUE;
END LoadILBM;
(*** Prozeduren zum Speichern von IFF-ILBM Bildern *******************)
PROCEDURE PackRow(VAR source,buff:ADDRESS; bpr:INTEGER);
VAR
count,a,b,c,i,pc:LONGINT;
help:ADDRESS;
BEGIN
count:=0;
REPEAT
a:=GetByte(source);
INC(count); INC(source);
IF count=bpr THEN
PutByte(0,buff); INC(buff);
PutByte(a,buff); INC(buff);
RETURN
END;
b:=GetByte(source);
IF a=b THEN
pc:=256;
WHILE (count<bpr) AND (a=b) DO
INC(count); INC(source);
DEC(pc);
b:=GetByte(source);
END;
PutByte(pc,buff); INC(buff);
PutByte(a,buff); INC(buff);
ELSE
pc:=-1;
help:=source-1;
WHILE (count<bpr) AND (a#b) DO
a:=b;
INC(count); INC(source);
INC(pc);
b:=GetByte(source);
END;
IF count=bpr THEN INC(pc) ELSE DEC(count); DEC(source) END;
PutByte(pc,buff); INC(buff);
FOR i:=0 TO pc DO
c:=GetByte(help); INC(help);
PutByte(c,buff); INC(buff);
END;
END;
UNTIL count>=bpr;
END PackRow;
PROCEDURE SaveILBM(fname:ARRAY OF CHAR;scr:ScreenPtr;
rmin,imin,rmax,imax:LONGREAL;maxiter:LONGINT):BOOLEAN;
VAR
buffer:ADDRESS;
len:LONGINT;
i,j:INTEGER;
bm:BitMapPtr;
colormap:POINTER TO ARRAY[0..31] OF INTEGER;
pl:ARRAY[0..7] OF ADDRESS;
BEGIN
bm:=ADR(scr^.bitMap);
bodybytes:=bm^.bytesPerRow*bm^.rows;
bodybytes:=bodybytes*INTEGER(bm^.depth);
lock:=Lock(ADR(fname),exclusiveLock);
IF lock#NIL THEN
Copy(message,fname);
Concat(message,"|already exists!|Shall I overwrite it?");
yes:="OK"; no:="CANCEL";
IF NOT Request(scr^.firstWindow,message,yes,no) THEN
UnLock(lock); lock:=NIL;
RETURN FALSE;
END;
UnLock(lock); lock:=NIL;
IF NOT DeleteFile(ADR(fname)) THEN
message:="Cannot overwrite|";Concat(message,fname);
yes:=""; no:="CANCEL";
IF Request(scr^.firstWindow,message,yes,no) THEN END;
RETURN FALSE;
END;
END;
f:=Open(ADR(fname),newFile);
IF f=NIL THEN
UnLock(lock); lock:=NIL;
message:="Cannot open file|"; Concat(message,fname);
yes:=""; no:="CANCEL";
IF Request(scr^.firstWindow,message,yes,no) THEN END;
RETURN FALSE;
END;
bodymem:=AllocMem(bodybytes,MemReqSet{public,memClear});
IF bodymem=NIL THEN
Close(f); UnLock(lock); lock:=NIL; f:=NIL;
message:="Not enough memory!"; yes:=""; no:="CANCEL";
IF Request(scr^.firstWindow,message,yes,no) THEN END;
RETURN FALSE;
END;
WITH ilbmheader.bmhd DO
w:=bm^.bytesPerRow*8;h:=bm^.rows;
x:=0;y:=0;planes:=CHAR(bm^.depth);masking:=CHAR(0);
compression:=CHAR(1);pad1:=CHAR(0);
transpcolor:=0;
xasp:=CHAR(1);yasp:=CHAR(1);
pagewidth:=bm^.bytesPerRow*8;pageheight:=bm^.rows;